home *** CD-ROM | disk | FTP | other *** search
/ Chip 2003 July / CMCD0703.ISO / Software / Test / audacity / audacity-win-1_1_3.exe / {app} / Nyquist / nyquist.lsp < prev    next >
Encoding:
Lisp/Scheme  |  2002-09-16  |  49.1 KB  |  1,523 lines
  1. ;;;
  2.  
  3. ;;;   ###########################################################
  4.  
  5. ;;;   ### NYQUIST-- A Language for Composition and Synthesis. ###
  6.  
  7. ;;;   ###                                                     ###
  8.  
  9. ;;;   ### Copyright (c) 1994 by Roger B. Dannenberg           ###
  10.  
  11. ;;;   ###########################################################
  12.  
  13. ;;;
  14.  
  15.  
  16.  
  17. ;;;   
  18.  
  19. ;;;   Modifications for using Nyquist within Audacity
  20.  
  21. ;;;   by Dominic Mazzoni
  22.  
  23. ;;;
  24.  
  25.  
  26.  
  27. (prog ()
  28.  
  29.    (setq lppp -12.0) (setq lpp -9.0)  (setq lp -6.0)    (setq lmp -3.0)
  30.  
  31.    (setq lfff 12.0) (setq lff 9.0)  (setq lf 6.0)    (setq lmf 3.0)
  32.  
  33.    (setq dB0 1.00)  (setq dB1 1.122) (setq dB10 3.1623)
  34.  
  35.  
  36.  
  37.    (setq s 0.25) (setq sd 0.375) (setq st (/ 0.5 3.0))
  38.  
  39.    (setq i 0.5)  (setq id 0.75)  (setq it (* st 2.0))
  40.  
  41.    (setq q 1.0)  (setq qd 1.5)   (setq qt (* st 4.0))
  42.  
  43.    (setq h 2.0)  (setq hd 3.0)   (setq ht (* st 8.0))
  44.  
  45.    (setq w 4.0)  (setq wd 6.0)   (setq wt (* st 16.0))
  46.  
  47. )
  48.  
  49.  
  50.  
  51. (if (not (boundp '*A4-Hertz*))
  52.  
  53.     (setf *A4-Hertz* 440.0))
  54.  
  55.  
  56.  
  57. ; next pitch, for initializations below
  58.  
  59. ; 
  60.  
  61. (defun np () (incf nyq:next-pitch))
  62.  
  63.  
  64.  
  65. (defun set-pitch-names ()
  66.  
  67.    (setq no-pitch 116.0)
  68.  
  69.    ; note: 58.0 is A4 - (C0 - 1) = 69 - (12 - 1)
  70.  
  71.    (setf nyq:next-pitch (- (hz-to-step *A4-Hertz*) 58.0))
  72.  
  73.  
  74.  
  75.    (setf nyq:pitch-names
  76.  
  77.     '(c0 (cs0 df0) d0 (ds0 ef0) e0 f0 (fs0 gf0) g0 (gs0 af0) a0
  78.  
  79.       (as0 bf0) b0
  80.  
  81.       c1 (cs1 df1) d1 (ds1 ef1) e1 f1 (fs1 gf1) g1 (gs1 af1) a1
  82.  
  83.       (as1 bf1) b1
  84.  
  85.       c2 (cs2 df2) d2 (ds2 ef2) e2 f2 (fs2 gf2) g2 (gs2 af2) a2
  86.  
  87.       (as2 bf2) b2
  88.  
  89.       c3 (cs3 df3) d3 (ds3 ef3) e3 f3 (fs3 gf3) g3 (gs3 af3) a3
  90.  
  91.       (as3 bf3) b3
  92.  
  93.       c4 (cs4 df4) d4 (ds4 ef4) e4 f4 (fs4 gf4) g4 (gs4 af4) a4
  94.  
  95.       (as4 bf4) b4
  96.  
  97.       c5 (cs5 df5) d5 (ds5 ef5) e5 f5 (fs5 gf5) g5 (gs5 af5) a5
  98.  
  99.       (as5 bf5) b5
  100.  
  101.       c6 (cs6 df6) d6 (ds6 ef6) e6 f6 (fs6 gf6) g6 (gs6 af6) a6
  102.  
  103.       (as6 bf6) b6
  104.  
  105.       c7 (cs7 df7) d7 (ds7 ef7) e7 f7 (fs7 gf7) g7 (gs7 af7) a7
  106.  
  107.       (as7 bf7) b7))
  108.  
  109.  
  110.  
  111.    (dolist (p nyq:pitch-names)
  112.  
  113.      (cond ((atom p) (set p (np)))
  114.  
  115.        (t (let ((pitch (np)))
  116.  
  117.         (dolist (s p) (set s pitch)))))))
  118.  
  119.  
  120.  
  121.  
  122.  
  123. (set-pitch-names)
  124.  
  125.  
  126.  
  127. (if (not (boundp '*DEFAULT-SOUND-SRATE*))
  128.  
  129.   (setf *DEFAULT-SOUND-SRATE* 44100.0))
  130.  
  131. (if (not (boundp '*DEFAULT-CONTROL-SRATE*))
  132.  
  133.   (setf *DEFAULT-CONTROL-SRATE* 2205.0))
  134.  
  135.  
  136.  
  137. (setf *environment-variables*
  138.  
  139.       '(*WARP* *SUSTAIN* *START* *LOUD* *TRANSPOSE* 
  140.  
  141.     *STOP* *CONTROL-SRATE* *SOUND-SRATE*))
  142.  
  143.  
  144.  
  145. (setfn environment-time car)
  146.  
  147. (setfn environment-stretch cadr)
  148.  
  149.  
  150.  
  151. ; ENVIRONMENT-MAP - map virtual time using an environment
  152.  
  153. ;
  154.  
  155. ;(defun environment-map (env tim)
  156.  
  157. ;  (+ (environment-time env)
  158.  
  159. ;     (* (environment-stretch env) tim)))
  160.  
  161.  
  162.  
  163.  
  164.  
  165. (defun nyq:the-environment () (mapcar 'eval *environment-variables*))
  166.  
  167.  
  168.  
  169.  
  170.  
  171. ;; GLOBAL ENVIRONMENT VARIABLES and their startup values:
  172.  
  173. (defun nyq:environment-init ()
  174.  
  175.   (setq *WARP*        '(0.0 1.0 nil))
  176.  
  177.   (setq *LOUD*    0.0)   ; now in dB
  178.  
  179.   (setq *TRANSPOSE*    0.0)
  180.  
  181.   (setq *SUSTAIN*            1.0)
  182.  
  183.   (setq *START*       MIN-START-TIME)
  184.  
  185.   (setq *STOP*        MAX-STOP-TIME)
  186.  
  187.   (setq *CONTROL-SRATE*  *DEFAULT-CONTROL-SRATE*)
  188.  
  189.   (setq *SOUND-SRATE* *DEFAULT-SOUND-SRATE*)
  190.  
  191.   t)                ; return nothing in particular
  192.  
  193.  
  194.  
  195. (nyq:environment-init)
  196.  
  197.  
  198.  
  199. (defun get-duration (dur)
  200.  
  201.   (- (local-to-global (* (get-sustain) dur))
  202.  
  203.      (setf *rslt* (local-to-global 0))))
  204.  
  205.  
  206.  
  207.  
  208.  
  209. (defun get-loud ()
  210.  
  211.   (cond ((numberp *loud*) *loud*)
  212.  
  213.     ((soundp *loud*)
  214.  
  215.      (sref *loud* 0))
  216.  
  217.     (t
  218.  
  219.      (error (format t "*LOUD* should be a number or sound: ~A" *LOUD*)))))
  220.  
  221.  
  222.  
  223.  
  224.  
  225. (defun get-sustain ()
  226.  
  227.   (cond ((numberp *SUSTAIN*) *SUSTAIN*)
  228.  
  229.     ((soundp *SUSTAIN*)
  230.  
  231.      ;(display "get-sustain: lookup " (local-to-global 0) 0))
  232.  
  233.      (sref *SUSTAIN* 0))
  234.  
  235.     (t
  236.  
  237.      (error (format t "*SUSTAIN* should be a number or sound: ~A" *SUSTAIN*)))))
  238.  
  239.  
  240.  
  241.  
  242.  
  243. (defun get-tempo ()
  244.  
  245.   (slope (snd-inverse (get-warp) (local-to-global 0)
  246.  
  247.               *control-srate*)))
  248.  
  249.  
  250.  
  251. (defun get-transpose ()
  252.  
  253.   (cond ((numberp *TRANSPOSE*) *TRANSPOSE*)
  254.  
  255.     ((soundp *TRANSPOSE*)
  256.  
  257.      ; (display "get-transpose: lookup " 0)
  258.  
  259.      ; (format t "samples: ~A~%" (snd-samples *TRANSPOSE* 100))
  260.  
  261.      (sref *TRANSPOSE* 0))
  262.  
  263.     (t
  264.  
  265.      (error (format t "*TRANSPOSE* should be a number or sound: ~A" *TRANSPOSE*)))))
  266.  
  267.  
  268.  
  269.  
  270.  
  271. (defun get-warp ()
  272.  
  273.   (let ((f (warp-function *WARP*)))
  274.  
  275.     (cond ((null f) (error "Null warp function"))
  276.  
  277.     (t
  278.  
  279.      (shift-time (scale-srate f (/ (warp-stretch *WARP*)))
  280.  
  281.              (- (warp-time *WARP*)))))))
  282.  
  283.  
  284.  
  285.  
  286.  
  287. ;;;;;;;;;;;;;;;;;;;;;;
  288.  
  289. ;; OSCILATORS
  290.  
  291. ;;;;;;;;;;;;;;;;;;;;;;
  292.  
  293.  
  294.  
  295. (defun build-harmonic (n table-size) (snd-sine 0 n table-size 1))
  296.  
  297.  
  298.  
  299. (setf *SINE-TABLE* (list (build-harmonic 1 2048)
  300.  
  301.              (hz-to-step 1.0)
  302.  
  303.              T))
  304.  
  305. (setf *TABLE* *SINE-TABLE*)
  306.  
  307.  
  308.  
  309.  
  310.  
  311. ;; AMOSC
  312.  
  313. ;;
  314.  
  315. (defun amosc (pitch modulation &optional (sound *table*) (phase 0.0))
  316.  
  317.   (let ((modulation-srate (snd-srate modulation))
  318.  
  319.     (hz (step-to-hz (+ pitch (get-transpose)))))
  320.  
  321.     (cond ((> *SOUND-SRATE* modulation-srate)
  322.  
  323.        (setf modulation (snd-up *SOUND-SRATE* modulation)))
  324.  
  325.       ((< *SOUND-SRATE* modulation-srate)
  326.  
  327.        (format t "Warning: down-sampling AM modulation in amosc~%")
  328.  
  329.        (setf modulation (snd-down *SOUND-SRATE* modulation))))
  330.  
  331.     (cond ((> hz (/ *SOUND-SRATE* 2))
  332.  
  333.        (format t "Warning: amosc frequency (~A hz) will alias at current sample rate (~A hz).\n"
  334.  
  335.            hz *SOUND-SRATE*)))
  336.  
  337.     (scale-db (get-loud)
  338.  
  339.       (snd-amosc
  340.  
  341.     (car sound)    ; samples for table
  342.  
  343.     (cadr sound)    ; step represented by table
  344.  
  345.     *SOUND-SRATE*    ; output sample rate
  346.  
  347.     hz        ;  output hz
  348.  
  349.     (local-to-global 0)    ; starting time
  350.  
  351.     modulation    ; modulation
  352.  
  353.     phase))))    ; phase
  354.  
  355.  
  356.  
  357.  
  358.  
  359. ;; FMOSC
  360.  
  361. ;;
  362.  
  363. ;; modulation rate must be less than or equal to sound-srate, so
  364.  
  365. ;; force resampling and issue a warning if necessary. snd-fmosc can
  366.  
  367. ;; handle upsampling cases internally.
  368.  
  369. ;;
  370.  
  371. (defun fmosc (pitch modulation &optional (sound *table*) (phase 0.0))
  372.  
  373.   (let ((modulation-srate (snd-srate modulation))
  374.  
  375.         (hz (step-to-hz (+ pitch (get-transpose)))))
  376.  
  377.     (cond ((< *SOUND-SRATE* modulation-srate)
  378.  
  379.        (format t "Warning: down-sampling FM modulation in fmosc~%")
  380.  
  381.        (setf modulation (snd-down *SOUND-SRATE* modulation))))
  382.  
  383.     (cond ((> hz (/ *SOUND-SRATE* 2))
  384.  
  385.        (format t "Warning: fmosc nominal frequency (~A hz) will alias at current sample rate (~A hz).\n"
  386.  
  387.            hz *SOUND-SRATE*)))
  388.  
  389.     (scale-db (get-loud)
  390.  
  391.       (snd-fmosc 
  392.  
  393.         (car sound)        ; samples for table
  394.  
  395.         (cadr sound)        ; step represented by table
  396.  
  397.         *SOUND-SRATE*        ; output sample rate
  398.  
  399.         hz            ;  output hz
  400.  
  401.         (local-to-global 0)    ; starting time
  402.  
  403.         modulation        ; modulation
  404.  
  405.         phase))))        ; phase
  406.  
  407.  
  408.  
  409.  
  410.  
  411. ;; BUZZ
  412.  
  413. ;;
  414.  
  415. ;; (ARGUMENTS ("long" "n") ("rate_type" "sr") ("double" "hz")
  416.  
  417. ;;            ("time_type" "t0") ("sound_type" "s_fm"))
  418.  
  419. ;; 
  420.  
  421. (defun buzz (n pitch modulation)
  422.  
  423.   (let ((modulation-srate (snd-srate modulation))
  424.  
  425.         (hz (step-to-hz (+ pitch (get-transpose)))))
  426.  
  427.     (cond ((< *SOUND-SRATE* modulation-srate)
  428.  
  429.            (format t "Warning: down-sampling modulation in buzz~%")
  430.  
  431.            (setf modulation (snd-down *SOUND-SRATE* modulation))))
  432.  
  433.     (cond ((> hz (/ *SOUND-SRATE* 2))
  434.  
  435.            (format t "Warning: buzz nominal frequency (~A hz) will alias at current sample rate (~A hz).\n"
  436.  
  437.                    hz *SOUND-SRATE*)))
  438.  
  439.     (setf n (min n 1)) ; avoid divide by zero problem
  440.  
  441.     (scale-db (get-loud)
  442.  
  443.               (snd-buzz n                   ; number of harmonics
  444.  
  445.                         *SOUND-SRATE*       ; output sample rate
  446.  
  447.                         hz                  ; output hz
  448.  
  449.                         (local-to-global 0) ; starting time
  450.  
  451.                         modulation))))      ; freq. modulation
  452.  
  453.                         
  454.  
  455.  
  456.  
  457. ;; (HZOSC hz [table [phase]])
  458.  
  459. ;;
  460.  
  461. ;; similar to FMOSC, but without "carrier" frequency parameter
  462.  
  463. ;; also, hz may be a scalar or a sound
  464.  
  465. ;;
  466.  
  467. (defun hzosc (hz &optional (sound *table*) (phase 0.0))
  468.  
  469.   (let (hz-srate)
  470.  
  471.     (cond ((numberp hz)
  472.  
  473.            (osc (hz-to-step hz) 1.0 sound phase))
  474.  
  475.           (t
  476.  
  477.            (setf hz-srate (snd-srate hz))
  478.  
  479.            (cond ((< *SOUND-SRATE* hz-srate)
  480.  
  481.                   (format t "Warning: down-sampling hz in hzosc~%")
  482.  
  483.                   (setf hz (snd-down *SOUND-SRATE* hz))))
  484.  
  485.            (scale-db (get-loud)
  486.  
  487.                      (snd-fmosc (car sound) ; samples for table
  488.  
  489.                                 (cadr sound) ; step repr. by table
  490.  
  491.                                 *SOUND-SRATE* ; output sample rate
  492.  
  493.                                 0.0 ; dummy carrier
  494.  
  495.                                 (local-to-global 0) ; starting time
  496.  
  497.                                 hz phase))))))
  498.  
  499.  
  500.  
  501.  
  502.  
  503. ;; (SIOSC-BREAKPOINTS tab0 t1 tab1 ... tn tabn)
  504.  
  505. ;;   converts times to sample numbers
  506.  
  507. ;; NOTE: time-warping the spectral envelope seems
  508.  
  509. ;; like the wrong thing to do (wouldn't it be better
  510.  
  511. ;; to warp the parameters that control the spectra,
  512.  
  513. ;; or don't warp at all?). Nominally, a note should
  514.  
  515. ;; have a "score" or local time duration equal to the
  516.  
  517. ;; SUSTAIN environment variable. (When sustain is 1.0
  518.  
  519. ;; and no time-warping is in effect, the duration is 1).
  520.  
  521. ;; So, scale all times by
  522.  
  523. ;;        (local-to-global (get-sustain))
  524.  
  525. ;; so that if the final time tn = 1.0, we get a nominal
  526.  
  527. ;; length note.
  528.  
  529.  
  530.  
  531. (defun siosc-breakpoints (breakpoints)
  532.  
  533.   (display "siosc-breakpoints" breakpoints)
  534.  
  535.   (prog (sample-count result (last-count 0) time-factor)
  536.  
  537.     (setf time-factor
  538.  
  539.       (- (local-to-global (get-sustain))
  540.  
  541.          (local-to-global 0.0)))
  542.  
  543.     (setf time-factor (* time-factor *SOUND-SRATE*))
  544.  
  545.     (cond ((and (listp breakpoints)
  546.  
  547.         (cdr breakpoints)
  548.  
  549.         (cddr breakpoints)))
  550.  
  551.       (t (error "SIOSC table list must have at least 3 elements")))
  552.  
  553. loop
  554.  
  555.     (cond ((and (listp breakpoints)
  556.  
  557.            (soundp (car breakpoints)))
  558.  
  559.        (push (car breakpoints) result)
  560.  
  561.        (setf breakpoints (cdr breakpoints)))
  562.  
  563.       (t
  564.  
  565.        (error "SIOSC expecting SOUND in table list")))
  566.  
  567.     (cond ((and breakpoints
  568.  
  569.         (listp breakpoints)
  570.  
  571.         (numberp (car breakpoints)))
  572.  
  573.        (setf sample-count (truncate
  574.  
  575.         (+ 0.5 (* time-factor (car breakpoints)))))
  576.  
  577.        (cond ((< sample-count last-count)
  578.  
  579.           (setf sample-count (1+ last-count))))
  580.  
  581.        (push sample-count result)
  582.  
  583.        (setf last-count sample-count)
  584.  
  585.        (setf breakpoints (cdr breakpoints))
  586.  
  587.        (cond (breakpoints
  588.  
  589.           (go loop))))
  590.  
  591.       (breakpoints
  592.  
  593.        (error "SIOSC expecting number (time) in table list")))
  594.  
  595.     (setf result (reverse result))
  596.  
  597.     (display "siosc-breakpoints" result)
  598.  
  599.     (return result)))
  600.  
  601.  
  602.  
  603. ;; SIOSC -- spectral interpolation oscillator
  604.  
  605. ;;
  606.  
  607. ;; modulation rate must be less than or equal to sound-srate, so
  608.  
  609. ;; force resampling and issue a warning if necessary. snd-fmosc can
  610.  
  611. ;; handle upsampling cases internally.
  612.  
  613. ;;
  614.  
  615. (defun siosc (pitch modulation breakpoints)
  616.  
  617.   (let ((modulation-srate (snd-srate modulation))
  618.  
  619.     (hz (step-to-hz (+ pitch (get-transpose)))))
  620.  
  621.     (cond ((< *SOUND-SRATE* modulation-srate)
  622.  
  623.        (format t "Warning: down-sampling FM modulation in siosc~%")
  624.  
  625.        (setf modulation (snd-down *SOUND-SRATE* modulation))))
  626.  
  627.     (cond ((> hz (/ *SOUND-SRATE* 2))
  628.  
  629.        (format t "Warning: siosc nominal frequency (~A hz) will alias at current sample rate (~A hz).\n"
  630.  
  631.            hz *SOUND-SRATE*)))
  632.  
  633.      (scale-db (get-loud)
  634.  
  635.       (snd-siosc 
  636.  
  637.     (siosc-breakpoints breakpoints)    ; tables
  638.  
  639.     *SOUND-SRATE*        ; output sample rate
  640.  
  641.     hz            ;  output hz
  642.  
  643.     (local-to-global 0)    ; starting time
  644.  
  645.     modulation))))        ; modulation
  646.  
  647.  
  648.  
  649.  
  650.  
  651. ;; LFO -- freq &optional duration sound phase)
  652.  
  653. ;;
  654.  
  655. ;; Default duration is 1.0 sec, default sound is *TABLE*, 
  656.  
  657. ;; default phase is 0.0.
  658.  
  659. ;;
  660.  
  661. (defun lfo (freq &optional (duration 1.0)
  662.  
  663.          (sound *SINE-TABLE*) (phase 0.0))
  664.  
  665.   (let ((d (get-duration duration)))
  666.  
  667.     (if (minusp d) (setf d 0))
  668.  
  669.     (cond ((> freq (/ *CONTROL-SRATE* 2))
  670.  
  671.        (format t "Warning: lfo frequency (~A hz) will alias at current control rate (~A hz).\n"
  672.  
  673.            freq *CONTROL-SRATE*)))
  674.  
  675.      (snd-osc
  676.  
  677.     (car sound)        ; samples for table
  678.  
  679.     (cadr sound)        ; step represented by table
  680.  
  681.     *CONTROL-SRATE*        ; output sample rate
  682.  
  683.     freq            ; output hz
  684.  
  685.     *rslt*            ; starting time
  686.  
  687.     d            ; duration
  688.  
  689.     phase)))        ; phase
  690.  
  691.  
  692.  
  693.  
  694.  
  695. ;; OSC - table lookup oscillator
  696.  
  697. ;;
  698.  
  699. (defun osc (pitch &optional (duration 1.0) 
  700.  
  701.           (sound *TABLE*) (phase 0.0))
  702.  
  703.   (let ((d (get-duration duration))
  704.  
  705.     (hz (step-to-hz (+ pitch (get-transpose)))))
  706.  
  707.     ;(display "osc" *warp* global-start global-stop actual-dur  
  708.  
  709.     ;         (get-transpose))
  710.  
  711.     (cond ((> hz (/ *SOUND-SRATE* 2))
  712.  
  713.        (format t "Warning: osc frequency (~A hz) will alias at current sample rate (~A hz).\n"
  714.  
  715.            hz *SOUND-SRATE*)))
  716.  
  717.      (set-logical-stop
  718.  
  719.      (scale-db (get-loud)
  720.  
  721.            (snd-osc 
  722.  
  723.         (car sound)        ; samples for table
  724.  
  725.         (cadr sound)        ; step represented by table
  726.  
  727.         *SOUND-SRATE*        ; output sample rate
  728.  
  729.         hz            ;  output hz
  730.  
  731.         *rslt*            ; starting time
  732.  
  733.         d            ; duration
  734.  
  735.         phase))                 ; phase
  736.  
  737.      duration)))
  738.  
  739.  
  740.  
  741.  
  742.  
  743. ;; PARTIAL -- sine osc with built-in envelope scaling
  744.  
  745. ;;
  746.  
  747. (defun partial (steps env)
  748.  
  749.   (let ((hz (step-to-hz (+ steps (get-transpose)))))
  750.  
  751.     (cond ((> hz (/ *SOUND-SRATE* 2))
  752.  
  753.        (format t "Warning: partial frequency (~A hz) will alias at current sample rate (~A hz).\n"
  754.  
  755.            hz *SOUND-SRATE*)))
  756.  
  757.     (snd-partial *sound-srate*
  758.  
  759.          hz
  760.  
  761.          env)))
  762.  
  763.  
  764.  
  765.  
  766.  
  767. ;; SAMPLER -- simple attack + sustain sampler
  768.  
  769. ;;
  770.  
  771. (defun sampler (pitch modulation 
  772.  
  773.         &optional (sample *table*) (npoints 2))
  774.  
  775.   (let ((samp (car sample))
  776.  
  777.     (samp-pitch (cadr sample))
  778.  
  779.     (samp-loop-start (caddr sample))
  780.  
  781.     (hz (step-to-hz (+ pitch (get-transpose)))))
  782.  
  783.     ; make a waveform table look like a sample with no attack:
  784.  
  785.     (cond ((not (numberp samp-loop-start))
  786.  
  787.        (setf samp-loop-start 0.0)))
  788.  
  789.     (cond ((> hz (/ *SOUND-SRATE* 2))
  790.  
  791.        (format t "Warning: sampler nominal frequency (~A hz) will alias at current sample rate (~A hz).\n"
  792.  
  793.            hz *SOUND-SRATE*)))
  794.  
  795.     (scale-db (get-loud)
  796.  
  797.        (snd-sampler 
  798.  
  799.     samp        ; samples for table
  800.  
  801.     samp-pitch        ; step represented by table
  802.  
  803.     samp-loop-start         ; time to start loop
  804.  
  805.     *SOUND-SRATE*        ; output sample rate
  806.  
  807.     hz            ;  output hz
  808.  
  809.     (local-to-global 0)    ; starting time
  810.  
  811.     modulation        ; modulation
  812.  
  813.     npoints))))        ; number of interpolation points
  814.  
  815.  
  816.  
  817.  
  818.  
  819. ;; SINE -- simple sine oscillator
  820.  
  821. ;;
  822.  
  823. (defun sine (steps &optional (duration 1.0))
  824.  
  825.   (let ((hz (step-to-hz (+ steps (get-transpose))))
  826.  
  827.     (d (get-duration duration)))
  828.  
  829.     (cond ((> hz (/ *SOUND-SRATE* 2))
  830.  
  831.        (format t "Warning: sine frequency (~A hz) will alias at current sample rate (~A hz).\n"
  832.  
  833.            hz *SOUND-SRATE*)))
  834.  
  835.     (snd-sine *rslt* hz *sound-srate* d)))
  836.  
  837.  
  838.  
  839.  
  840.  
  841. ;; PLUCK
  842.  
  843. ;;
  844.  
  845. ;; (ARGUMENTS ("double" "sr") ("double" "hz") ("time_type" "t0") 
  846.  
  847. ;;            ("time_type" "d") ("double" "final_amp"))
  848.  
  849. ;;
  850.  
  851. (defun pluck (steps &optional (duration 1.0) (final-amp 0.001))
  852.  
  853.   (let ((hz (step-to-hz (+ steps (get-transpose))))
  854.  
  855.         (d (get-duration duration)))
  856.  
  857.     (cond ((> hz (/ *SOUND-SRATE* 2))
  858.  
  859.        (format t "Warning: pluck frequency (~A hz) will alias at current sample rate (~A hz).\n"
  860.  
  861.            hz *SOUND-SRATE*)))
  862.  
  863.     (snd-pluck *SOUND-SRATE* hz *rslt* d final-amp)))
  864.  
  865.  
  866.  
  867.  
  868.  
  869.  
  870.  
  871.  
  872.  
  873. ;; abs-env -- restore the standard environment
  874.  
  875. ;;
  876.  
  877. (defmacro abs-env (s)
  878.  
  879.   `(progv '(*WARP* *LOUD* *TRANSPOSE* *SUSTAIN* 
  880.  
  881.         *START* *STOP* *CONTROL-SRATE* *SOUND-SRATE*)
  882.  
  883.       (list '(0.0 1.0 NIL) 0.0 0.0 1.0
  884.  
  885.         -1e+9 1e+9 *DEFAULT-CONTROL-SRATE* *DEFAULT-SOUND-SRATE*)
  886.  
  887.       ,s))
  888.  
  889.  
  890.  
  891.  
  892.  
  893. ; nyq:add2 - add two arguments
  894.  
  895. ; 
  896.  
  897. (defun nyq:add2 (s1 s2)
  898.  
  899.     (cond ((and (arrayp s1) (not (arrayp s2)))
  900.  
  901.        (setf s2 (vector s2)))
  902.  
  903.       ((and (arrayp s2) (not (arrayp s1)))
  904.  
  905.        (setf s1 (vector s1))))
  906.  
  907.     (cond ((arrayp s1)
  908.  
  909.        (sum-of-arrays s1 s2))
  910.  
  911.       (t
  912.  
  913.        (nyq:add-2-sounds s1 s2))))
  914.  
  915.  
  916.  
  917.  
  918.  
  919. ; (NYQ:ADD-2-SOUNDS S1 S2) - add two sound (or number) arguments
  920.  
  921. ; 
  922.  
  923. (defun nyq:add-2-sounds (s1 s2)
  924.  
  925.   (cond ((numberp s1)
  926.  
  927.      (cond ((numberp s2)
  928.  
  929.         (+ s1 s2))
  930.  
  931.            (t
  932.  
  933.         (snd-offset s2 s1))))
  934.  
  935.     ((numberp s2)
  936.  
  937.      (snd-offset s1 s2))
  938.  
  939.     (t
  940.  
  941.      (let ((s1sr (snd-srate s1))
  942.  
  943.            (s2sr (snd-srate s2)))
  944.  
  945. ;    (display "nyq:add-2-sounds" s1sr s2sr)
  946.  
  947.        (cond ((> s1sr s2sr)
  948.  
  949.           (snd-add s1 (snd-up s1sr s2)))
  950.  
  951.          ((< s1sr s2sr)
  952.  
  953.           (snd-add (snd-up s2sr s1) s2))
  954.  
  955.          (t
  956.  
  957.           (snd-add s1 s2)))))))
  958.  
  959.  
  960.  
  961.  
  962.  
  963.  
  964.  
  965.  
  966.  
  967. (defmacro at (x s)
  968.  
  969.  `(progv '(*WARP*) (list (list (+ (warp-time *WARP*) 
  970.  
  971.                   (* (warp-stretch *WARP*) ,x))
  972.  
  973.                    (warp-stretch *WARP*)
  974.  
  975.                    (warp-function *WARP*)))
  976.  
  977.       ,s))
  978.  
  979.  
  980.  
  981.  
  982.  
  983. ;; (AT-ABS t behavior) evaluate behavior at global time t
  984.  
  985. ;;
  986.  
  987. ;; *WARP* is the triple (d s f) denoting the function f(st+d),
  988.  
  989. ;; a mapping from local to global time.
  990.  
  991. ;; We want (d' s f) such that f(s*0 + d') = t
  992.  
  993. ;; (Note that we keep the same s and f, and only change the offset.
  994.  
  995. ;; To eliminate the warp and stretch use "(abs-env (at t behavior))")
  996.  
  997. ;; Applying the inverse of f, d' = f-1(t), or (sref (snd-inverse f ...) t)
  998.  
  999. ;; Rather than invert the entire function just to evaluate at one point,
  1000.  
  1001. ;; we use SREF-INVERSE to find d'.
  1002.  
  1003. ;;
  1004.  
  1005. (defmacro at-abs (x s)
  1006.  
  1007.  `(progv '(*WARP*)
  1008.  
  1009.      (if (warp-function *WARP*)
  1010.  
  1011.                (list (list (sref-inverse (warp-function *WARP*) ,x)
  1012.  
  1013.                    (warp-stretch *WARP*)
  1014.  
  1015.                    (warp-function *WARP*)))
  1016.  
  1017.                (list (list ,x (warp-stretch *WARP*) NIL)))
  1018.  
  1019.      ,s))
  1020.  
  1021.  
  1022.  
  1023. ;; (CLIP S1 VALUE) - clip maximum amplitude to value
  1024.  
  1025. ;
  1026.  
  1027. (defun clip (x v)
  1028.  
  1029.   (cond ((numberp x)
  1030.  
  1031.      (max (min x v) (- v)))
  1032.  
  1033.     ((arrayp x)
  1034.  
  1035.      (let* ((len (length x))
  1036.  
  1037.         (result (make-array len)))
  1038.  
  1039.         (dotimes (i len)
  1040.  
  1041.         (setf (aref result i) 
  1042.  
  1043.               (snd-clip (aref x i) v)))
  1044.  
  1045.         result))
  1046.  
  1047.     (t
  1048.  
  1049.      (snd-clip x v))))
  1050.  
  1051.  
  1052.  
  1053. ;; (NYQ:COERCE-TO S1 S2) - expand sound s1 to type of s2
  1054.  
  1055. ; 
  1056.  
  1057. (defun nyq:coerce-to (s1 s2)
  1058.  
  1059.   (cond ((soundp s1)
  1060.  
  1061.      (cond ((arrayp s2)
  1062.  
  1063.         (nyq:sound-to-array s1 (length s2)))
  1064.  
  1065.            (t s1)))
  1066.  
  1067.     (t s1)))
  1068.  
  1069.  
  1070.  
  1071.  
  1072.  
  1073. (defmacro continuous-control-warp (beh)
  1074.  
  1075.   `(snd-compose (warp-abs nil ,beh)
  1076.  
  1077.         (snd-inverse (get-warp)
  1078.  
  1079.          (local-to-global 0) *control-srate*)))
  1080.  
  1081.  
  1082.  
  1083. (defmacro continuous-sound-warp (beh)
  1084.  
  1085.   `(snd-compose (warp-abs nil ,beh)
  1086.  
  1087.         (snd-inverse (get-warp)
  1088.  
  1089.          (local-to-global 0) *sound-srate*)))
  1090.  
  1091.  
  1092.  
  1093.  
  1094.  
  1095. (defmacro control-srate-abs (r s)
  1096.  
  1097.   `(progv '(*CONTROL-SRATE*) (list ,r)
  1098.  
  1099.       ,s))
  1100.  
  1101.  
  1102.  
  1103. ; db = 20log(ratio)
  1104.  
  1105. ; db = 20 ln(ratio)/ln(10)
  1106.  
  1107. ; db/20 = ln(ratio)/ln(10)
  1108.  
  1109. ; db ln(10)/20 = ln(ratio)
  1110.  
  1111. ; e^(db ln(10)/20) = ratio
  1112.  
  1113. ;
  1114.  
  1115. (setf ln10over20 (/ (log 10.0) 20))
  1116.  
  1117.  
  1118.  
  1119. (defun db-to-linear (x) 
  1120.  
  1121.   (cond ((numberp x)
  1122.  
  1123.      (exp (* ln10over20 x)))
  1124.  
  1125.     ((arrayp x)
  1126.  
  1127.      (let* ((len (length x))
  1128.  
  1129.         (result (make-array len)))
  1130.  
  1131.         (dotimes (i len)
  1132.  
  1133.         (setf (aref result i) 
  1134.  
  1135.               (snd-exp (snd-scale ln10over20 (aref snd i)))))
  1136.  
  1137.         result))
  1138.  
  1139.     (t
  1140.  
  1141.      (snd-exp (snd-scale ln10over20 x)))))
  1142.  
  1143.  
  1144.  
  1145.  
  1146.  
  1147. (defun linear-to-db (x) 
  1148.  
  1149.   (cond ((numberp x)
  1150.  
  1151.      (/ (log (float x)) ln10over20))
  1152.  
  1153.     ((arrayp x)
  1154.  
  1155.      (let* ((len (length x))
  1156.  
  1157.         (result (make-array len)))
  1158.  
  1159.         (dotimes (i len)
  1160.  
  1161.         (setf (aref result i) 
  1162.  
  1163.               (snd-scale (/ 1.0 ln10over20) (snd-log (aref snd i)))))
  1164.  
  1165.         result))
  1166.  
  1167.     (t
  1168.  
  1169.      (snd-scale (/ 1.0 ln10over20) (snd-log x)))))
  1170.  
  1171.  
  1172.  
  1173. ; sref - access a sound at a given time point
  1174.  
  1175. ;    note that the time is transformed to global
  1176.  
  1177. (defun sref (sound point)
  1178.  
  1179.   (snd-sref sound (local-to-global point)))
  1180.  
  1181.  
  1182.  
  1183.  
  1184.  
  1185. ; extract - start is stretched and shifted as is stop
  1186.  
  1187. ;  result is shifted to start at local time zero
  1188.  
  1189. (defun extract (start stop sound)
  1190.  
  1191.   (snd-xform sound (snd-srate sound) (local-to-global 0) 
  1192.  
  1193.          (local-to-global start) (local-to-global stop) 1.0))
  1194.  
  1195.  
  1196.  
  1197. (defun extract-abs (start stop sound)
  1198.  
  1199.   (snd-xform sound (snd-srate sound) 0 start stop 1.0))
  1200.  
  1201.      
  1202.  
  1203.  
  1204.  
  1205. ;(defmacro extract (start stop sound)
  1206.  
  1207. ;  `(let ($newsound)
  1208.  
  1209. ;     (progv '(*START* *STOP*)
  1210.  
  1211. ;            (list (local-to-global ,start)
  1212.  
  1213. ;          (local-to-global ,stop))
  1214.  
  1215. ;            (setf $newsound ,sound)
  1216.  
  1217. ;            (setf $newsound 
  1218.  
  1219. ;                  (loud-abs 0 (cue (set-logical-stop-abs $newsound *STOP*)))))
  1220.  
  1221. ;     $newsound))
  1222.  
  1223.  
  1224.  
  1225.  
  1226.  
  1227. ;(defmacro extract-abs (start stop sound)
  1228.  
  1229. ;  `(let ($newsound $newstart)
  1230.  
  1231. ;     (progv '(*START* *STOP*)
  1232.  
  1233. ;            (list ,start ,stop)
  1234.  
  1235. ;        (setf $newstart *START*)
  1236.  
  1237. ;            (setf $newsound ,sound)            
  1238.  
  1239. ;            (setf $newsound (set-logical-stop-abs $newsound *STOP*)))
  1240.  
  1241. ;     (snd-xform $newsound (snd-srate $newsound) ,start ,stop 1.0)))
  1242.  
  1243.  
  1244.  
  1245.  
  1246.  
  1247. (defun local-to-global (local-time)
  1248.  
  1249.   (let ((d (warp-time *WARP*))
  1250.  
  1251.     (s (warp-stretch *WARP*))
  1252.  
  1253.     (w (warp-function *WARP*))
  1254.  
  1255.     global-time)
  1256.  
  1257.     (setf global-time (+ (* s local-time) d))
  1258.  
  1259.     (if w (snd-sref w global-time) global-time)))
  1260.  
  1261.  
  1262.  
  1263.  
  1264.  
  1265. (defmacro loud (x s)
  1266.  
  1267.  `(progv '(*LOUD*) (list (sum *LOUD* ,x))
  1268.  
  1269.      ,s))
  1270.  
  1271.  
  1272.  
  1273.  
  1274.  
  1275. (defmacro loud-abs (x s)
  1276.  
  1277.  `(progv '(*LOUD*) (list ,x)
  1278.  
  1279.      ,s))
  1280.  
  1281.  
  1282.  
  1283. (defun must-be-sound (x)
  1284.  
  1285.  (cond ((soundp x) x)
  1286.  
  1287.        (t
  1288.  
  1289.     (error "SOUND type expected" x))))
  1290.  
  1291.  
  1292.  
  1293. ;; SCALE-DB -- same as scale, but argument is in db
  1294.  
  1295. ;;
  1296.  
  1297. (defun scale-db (factor sound)
  1298.  
  1299.   (scale (db-to-linear factor) sound))
  1300.  
  1301.  
  1302.  
  1303. (defun set-control-srate (rate)
  1304.  
  1305.   (setf *default-control-srate* (float rate))
  1306.  
  1307.   (nyq:environment-init))
  1308.  
  1309.  
  1310.  
  1311. (defun set-sound-srate (rate) 
  1312.  
  1313.   (setf *default-sound-srate* (float rate))
  1314.  
  1315.   (nyq:environment-init))
  1316.  
  1317.  
  1318.  
  1319.  
  1320.  
  1321. ; s-plot -- compute and write n data points for plotting
  1322.  
  1323. ; 
  1324.  
  1325. (defun s-plot (snd &optional (n 1000))
  1326.  
  1327.   (prog ((points (snd-samples snd (1+ n)))
  1328.  
  1329.      (filename (soundfilename *default-plot-file*))
  1330.  
  1331.      outf
  1332.  
  1333.      (period (/ 1.0 (snd-srate snd)))
  1334.  
  1335.      len 
  1336.  
  1337.      (maximum 1.0))
  1338.  
  1339.     (setf outf (open filename :direction :output))
  1340.  
  1341.     (cond ((null outf)
  1342.  
  1343.        (format t "s-plot: could not open ~A!~%" filename)
  1344.  
  1345.        (return nil)))
  1346.  
  1347.     (format t "s-plot: writing ~A ... ~%" filename)
  1348.  
  1349.     (setf len (length points))
  1350.  
  1351.     (cond ((> len n)
  1352.  
  1353.        (setf len n)
  1354.  
  1355.        (format t "WARNING: SOUND TRUNCATED TO ~A POINTS~%" len)))
  1356.  
  1357.     (dotimes (i len)
  1358.  
  1359.       (cond ((< (abs maximum) (abs (aref points i)))
  1360.  
  1361.          (setf maximum (aref points i))))
  1362.  
  1363.       (format outf "~A ~A~%" (* i period) (aref points i)))
  1364.  
  1365.     (close outf)
  1366.  
  1367.     (cond ((> (abs maximum) 1.0)
  1368.  
  1369.        (format t "WARNING: MAXIMUM AMPLITUDE IS ~A~%" maximum)))
  1370.  
  1371.     (format t "~A points from ~A to ~A~%"
  1372.  
  1373.      len (snd-t0 snd) (+ (snd-t0 snd) (* len period)))))
  1374.  
  1375.  
  1376.  
  1377. ; run something like this to plot the points:
  1378.  
  1379. ; graph < points.dat | plot -Ttek
  1380.  
  1381.  
  1382.  
  1383.  
  1384.  
  1385. (defmacro sound-srate-abs (r s)
  1386.  
  1387.   `(progv '(*SOUND-SRATE*) (list ,r)
  1388.  
  1389.       ,s))
  1390.  
  1391.  
  1392.  
  1393.  
  1394.  
  1395. (defmacro stretch (x s)
  1396.  
  1397.  `(progv '(*WARP*) (list (list (warp-time *WARP*) 
  1398.  
  1399.                    (* (warp-stretch *WARP*) ,x)
  1400.  
  1401.                    (warp-function *WARP*)))
  1402.  
  1403.      (if (minusp (warp-stretch *WARP*))
  1404.  
  1405.          (break "Negative stretch factor is not allowed"))
  1406.  
  1407.              ,s))
  1408.  
  1409.  
  1410.  
  1411.          
  1412.  
  1413. (defmacro stretch-abs (x s)
  1414.  
  1415.  `(progv '(*WARP*) (list (list (local-to-global 0)
  1416.  
  1417.                    ,x
  1418.  
  1419.                    nil))
  1420.  
  1421.      (if (minusp (warp-stretch *WARP*))
  1422.  
  1423.          (break "Negative stretch factor is not allowed"))
  1424.  
  1425.              ,s))
  1426.  
  1427.  
  1428.  
  1429.  
  1430.  
  1431. (defmacro sustain (x s)
  1432.  
  1433.  `(progv '(*SUSTAIN*) (list (prod *SUSTAIN* ,x))
  1434.  
  1435.       ,s))
  1436.  
  1437.  
  1438.  
  1439.  
  1440.  
  1441. (defmacro sustain-abs (x s)
  1442.  
  1443.  `(progv '(*SUSTAIN*) (list ,x)
  1444.  
  1445.       ,s))
  1446.  
  1447.  
  1448.  
  1449.  
  1450.  
  1451. ;; (WARP-FUNCTION *WARP*) - extracts function field of warp triple
  1452.  
  1453. ;;
  1454.  
  1455. (setfn warp-function caddr)
  1456.  
  1457.  
  1458.  
  1459.  
  1460.  
  1461. ;; (WARP-STRETCH *WARP*) - extracts stretch field of warp triple
  1462.  
  1463. ;;
  1464.  
  1465. (setfn warp-stretch cadr)
  1466.  
  1467.  
  1468.  
  1469.  
  1470.  
  1471. ;; (WARP-TIME *WARP*) - extracts time field of warp triple
  1472.  
  1473. ;;
  1474.  
  1475. (setfn warp-time car)
  1476.  
  1477.  
  1478.  
  1479.  
  1480.  
  1481. (defmacro transpose (x s)
  1482.  
  1483.  `(progv '(*TRANSPOSE*) (list (sum *TRANSPOSE* ,x))
  1484.  
  1485.       ,s))
  1486.  
  1487.  
  1488.  
  1489.  
  1490.  
  1491. (defmacro transpose-abs (x s)
  1492.  
  1493.  `(progv '(*TRANSPOSE*) (list ,x)
  1494.  
  1495.       ,s))
  1496.  
  1497.  
  1498.  
  1499.  
  1500.  
  1501. ;; CONTROL-WARP -- apply a warp function to a control function
  1502.  
  1503. ;; 
  1504.  
  1505. (defun control-warp (warp-fn control &optional wrate)
  1506.  
  1507.   (cond (wrate
  1508.  
  1509.      (snd-resamplev control *control-srate*
  1510.  
  1511.             (snd-inverse warp-fn (local-to-global 0) wrate)))
  1512.  
  1513.     (t
  1514.  
  1515.      (snd-compose control
  1516.  
  1517.               (snd-inverse warp-fn (local-to-global 0) *control-srate*)))))
  1518.  
  1519.  
  1520.  
  1521.  
  1522.  
  1523. ;; (cue sound)
  1524.  
  1525. ;;    Cues the given sound; that is, it applies the current *WARP*, *LOUD*,
  1526.  
  1527. ;; *START*, and *STOP* values to the argument.  The logical start time is at
  1528.  
  1529. ;; local time 0.
  1530.  
  1531. (defun cue (sound)
  1532.  
  1533.   (cond ((arrayp sound)
  1534.  
  1535.      (let* ((len (length sound))
  1536.  
  1537.         (result (make-array len)))
  1538.  
  1539.         (dotimes (i len)
  1540.  
  1541.         (setf (aref result i)
  1542.  
  1543.               (cue-sound (aref sound i))))
  1544.  
  1545.         result))
  1546.  
  1547.     (t
  1548.  
  1549.      (cue-sound sound))))
  1550.  
  1551.  
  1552.  
  1553. (defun cue-sound (sound)
  1554.  
  1555.   (snd-xform sound
  1556.  
  1557.          (snd-srate sound)
  1558.  
  1559.          (local-to-global 0) *START* *STOP* (db-to-linear (get-loud))))
  1560.  
  1561.  
  1562.  
  1563. ;; (sound sound)
  1564.  
  1565. ;;    Same as (cue sound), except also warps the sound.
  1566.  
  1567. ;; Note that the *WARP* can change the pitch of the
  1568.  
  1569. ;; sound as a result of resampling.
  1570.  
  1571. ;; Here's the derivation for the warping code:
  1572.  
  1573. ;; *WARP* is a triple: (d s f) which denotes that the warp from local to
  1574.  
  1575. ;; global time is: f(st+d)
  1576.  
  1577. ;; We need to compose sound with the inverse of this to get a function
  1578.  
  1579. ;; of global time
  1580.  
  1581. ;; Let f-1 be the inverse of f.  Then the inverse of f(st+d) is 
  1582.  
  1583. ;; (f-1(t) - d)/s
  1584.  
  1585. ;; The composition gives us: (snd-compose sound (f-1(t) - d)/s)
  1586.  
  1587. ;; Eliminate the 1/s term by changing the sample rate of sound:
  1588.  
  1589. ;;  = (snd-compose (snd-scale-srate sound s) (f-1(t) - d))
  1590.  
  1591. ;; Eliminate the -d term by shifting f before taking the inverse:
  1592.  
  1593. ;;  = (snd-compose (scale-srate sound s) ((inverse f) - d))
  1594.  
  1595. ;;  = (snd-compose (scale-srate sound s) (inverse f(t + d)))
  1596.  
  1597. ;;  = (snd-compose (scale-srate sound s) (inverse (shift f -d)))
  1598.  
  1599. ;; snd-inverse takes a time and sample rate.  For time, use zero.
  1600.  
  1601. ;; The sample rate of inverse determines the final sample rate of
  1602.  
  1603. ;; this function, so use *SOUND-SRATE*:
  1604.  
  1605. ;;  = (snd-compose (scale-srate sound s) (snd-inverse (shift-time f (- d))
  1606.  
  1607. ;;                                              0 *SOUND-SRATE*))
  1608.  
  1609. ;;
  1610.  
  1611. (defun sound (sound)
  1612.  
  1613.    (cond ((null (warp-function *WARP*))
  1614.  
  1615.       (snd-xform sound (/ (snd-srate sound) (warp-stretch *WARP*))
  1616.  
  1617.              (local-to-global 0)
  1618.  
  1619.              *START* *STOP* (db-to-linear (get-loud))))
  1620.  
  1621.      (t
  1622.  
  1623.       (snd-compose (scale-srate sound (warp-stretch *WARP*))
  1624.  
  1625.                (snd-inverse (shift-time (warp-function *WARP*)
  1626.  
  1627.                         (- (warp-time *WARP*)))
  1628.  
  1629.                     0 *SOUND-SRATE*)))))
  1630.  
  1631.  
  1632.  
  1633.  
  1634.  
  1635. ;; (SCALE-SRATE SOUND SCALE)
  1636.  
  1637. ;; multiplies the sample rate by scale
  1638.  
  1639. (defun scale-srate (sound scale)
  1640.  
  1641.   (let ((new-srate (* scale (snd-srate sound))))
  1642.  
  1643.     (snd-xform sound new-srate (snd-time sound) 
  1644.  
  1645.            MIN-START-TIME MAX-STOP-TIME 1.0)))
  1646.  
  1647.  
  1648.  
  1649.  
  1650.  
  1651. ;; (SHIFT-TIME SOUND SHIFT)
  1652.  
  1653. ;; shift the time of a function by SHIFT, i.e. if SOUND is f(t),
  1654.  
  1655. ;; then (shift-time SOUND SHIFT) is f(t - SHIFT).  Note that if
  1656.  
  1657. ;; you look at plots, the shifted sound will move *right* when SHIFT
  1658.  
  1659. ;; is positive.  
  1660.  
  1661. (defun shift-time (sound shift)
  1662.  
  1663.   (snd-xform sound (snd-srate sound) (+ (snd-t0 sound) shift)
  1664.  
  1665.          MIN-START-TIME MAX-STOP-TIME 1.0))
  1666.  
  1667.  
  1668.  
  1669.  
  1670.  
  1671. ;; (NYQ:SOUND-TO-ARRAY SOUND N) - duplicate SOUND to N channels
  1672.  
  1673. ;;
  1674.  
  1675. (defun nyq:sound-to-array (sound n)
  1676.  
  1677.   (let ((result (make-array n)))
  1678.  
  1679.     (dotimes (i n)
  1680.  
  1681.       (setf (aref result i) sound))
  1682.  
  1683.     result))
  1684.  
  1685.  
  1686.  
  1687.  
  1688.  
  1689. ;; (control sound)
  1690.  
  1691. ;;    Same as (sound sound), except this is used for control signals.  
  1692.  
  1693. ;;    This code is identical to sound.
  1694.  
  1695. (setfn control sound)
  1696.  
  1697.  
  1698.  
  1699.  
  1700.  
  1701. ;; (env t1 t2 t4 l1 l2 l3 &optional duration)
  1702.  
  1703. ;; Creates a 4-phase envelope.
  1704.  
  1705. ;;    tN is the duration of phase N, and lN is the final level of
  1706.  
  1707. ;;    phase N.  t3 is implied by the duration, and l4 is 0.0.
  1708.  
  1709. ;;    If dur is not supplied, then 1.0 is assumed.  The envelope
  1710.  
  1711. ;;    duration is the product of dur, *STRETCH*, and *SUSTAIN*.  If 
  1712.  
  1713. ;;    t1 + t2 + 2ms + t4 > duration, then a two-phase envelope is
  1714.  
  1715. ;;    substituted that has an attack/release time ratio = t1/t4.
  1716.  
  1717. ;;    The sample rate of the returned sound is *CONTROL-SRATE*.
  1718.  
  1719. ;;
  1720.  
  1721. ;; Time transformation: the envelope is not warped; the start time and
  1722.  
  1723. ;; stop times are warped to global time.  Then the value of *SUSTAIN* at
  1724.  
  1725. ;; the begining of the envelope is used to determing absolute duration.
  1726.  
  1727. ;; Since PWL is ultimately called to create the envelope, we must use
  1728.  
  1729. ;; ABS-ENV to prevent any further transforms inside PWL.  We use
  1730.  
  1731. ;; (AT global-start ...) inside ABS-ENV so that the final result has 
  1732.  
  1733. ;; the proper starting time.
  1734.  
  1735. ;;
  1736.  
  1737. (defun env (t1 t2 t4 l1 l2 l3 &optional (duration 1.0))
  1738.  
  1739.   (let (actual-dur min-dur ratio t3
  1740.  
  1741.     (actual-dur (get-duration duration)))
  1742.  
  1743.     (setf min-dur (+ t1 t2 t4 0.002))
  1744.  
  1745.     (cond ((< actual-dur min-dur)
  1746.  
  1747.        (setf ratio (/ t1 (+ t1 t4)))
  1748.  
  1749.        (setf t1 (* ratio actual-dur))
  1750.  
  1751.        (setf t2 (- actual-dur t1))
  1752.  
  1753.        (setf t3 0.0)
  1754.  
  1755.        (setf t4 0.0)
  1756.  
  1757.        (setf l2 0.0)
  1758.  
  1759.        (setf l3 0.0))
  1760.  
  1761.       (t
  1762.  
  1763.        (setf t3 (- actual-dur t1 t2 t4))))
  1764.  
  1765.     (set-logical-stop
  1766.  
  1767.      (abs-env (at *rslt*
  1768.  
  1769.           (pwl t1 l1 (+ t1 t2) l2 (- actual-dur t4) l3 actual-dur)))
  1770.  
  1771.      duration)))
  1772.  
  1773.  
  1774.  
  1775.  
  1776.  
  1777. (defun gate (sound lookahead risetime falltime floor threshold)
  1778.  
  1779.     (cond ((< lookahead risetime)
  1780.  
  1781.            (break "lookahead must be greater than risetime in GATE function"))
  1782.  
  1783.           ((or (< risetime 0) (< falltime 0) (< floor 0))
  1784.  
  1785.            (break "risetime, falltime, and floor must all be positive in GATE function"))
  1786.  
  1787.           (t
  1788.  
  1789.            (let ((s
  1790.  
  1791.               (snd-gate (seq (cue sound) (abs-env (s-rest lookahead)))
  1792.  
  1793.                     lookahead risetime falltime floor threshold)))
  1794.  
  1795.              (snd-xform s (snd-srate s) (snd-t0 sound) 
  1796.  
  1797.             (+ (snd-t0 sound) lookahead) MAX-STOP-TIME 1.0)))))
  1798.  
  1799.  
  1800.  
  1801.  
  1802.  
  1803. ;; (osc-note step &optional duration env sust volume sound)
  1804.  
  1805. ;;   Creates a note using table-lookup osc, but with an envelope.
  1806.  
  1807. ;; The ENV parameter may be a parameter list for the env function,
  1808.  
  1809. ;; or it may be a sound.
  1810.  
  1811. ;;
  1812.  
  1813. (defun osc-note (pitch &optional (duration 1.0) 
  1814.  
  1815.                (env-spec '(0.02 0.1 0.3 1.0 .8 .7))
  1816.  
  1817.                (volume 0.0)
  1818.  
  1819.                (table *TABLE*))
  1820.  
  1821.   (set-logical-stop
  1822.  
  1823.    (mult (loud volume (osc pitch duration table))
  1824.  
  1825.      (if (listp env-spec)
  1826.  
  1827.        (apply 'env env-spec)
  1828.  
  1829.        env-spec))
  1830.  
  1831.    duration))
  1832.  
  1833.  
  1834.  
  1835.  
  1836.  
  1837. ;; force-srate -- resample snd if necessary to get sample rate
  1838.  
  1839. ;
  1840.  
  1841. (defun force-srate (sr snd)
  1842.  
  1843.   (cond ((not (numberp sr))
  1844.  
  1845.      (error "force-srate: SR should be a number")))
  1846.  
  1847.   (cond ((arrayp snd)
  1848.  
  1849.      (let* ((len (length snd))
  1850.  
  1851.         (result (make-array len)))
  1852.  
  1853.        (dotimes (i len)
  1854.  
  1855.             (setf (aref result i) 
  1856.  
  1857.               (force-srate sr (aref snd i))))
  1858.  
  1859.        result))
  1860.  
  1861.     (t
  1862.  
  1863.      (let ((snd-sr (snd-srate snd)))
  1864.  
  1865.        (cond ((> sr snd-sr) (snd-up sr snd))
  1866.  
  1867.          ((< sr snd-sr) (snd-down sr snd))
  1868.  
  1869.          (t snd))))))
  1870.  
  1871.  
  1872.  
  1873.  
  1874.  
  1875. (defun force-srates (srs snd)
  1876.  
  1877.   (cond ((and (numberp srs) (soundp snd))
  1878.  
  1879.      (force-srate srs snd))
  1880.  
  1881.     ((and (arrayp srs) (arrayp snd))
  1882.  
  1883.      (let* ((len (length snd))
  1884.  
  1885.         (result (make-array len)))
  1886.  
  1887.        (dotimes (i len)
  1888.  
  1889.             (setf (aref result i) 
  1890.  
  1891.               (force-srate (aref srs i) (aref snd i))))
  1892.  
  1893.        result))
  1894.  
  1895.     (t (error "arguments not compatible"))))
  1896.  
  1897.  
  1898.  
  1899.  
  1900.  
  1901. ;; (breakpoints-convert (t1 x1 t2 x2 ... tn) t0)
  1902.  
  1903. ;;   converts times to sample numbers and scales amplitudes
  1904.  
  1905. ;;   t0 is the global (after warping) start time
  1906.  
  1907. ;;
  1908.  
  1909. ;; NOTE: there were some stack overflow problems with the original
  1910.  
  1911. ;; recursive version (in comments now), so it was rewritten as an
  1912.  
  1913. ;; iteration.
  1914.  
  1915. ;;
  1916.  
  1917. (defun breakpoints-convert (list t0)
  1918.  
  1919.   (prog (sample-count result sust (last-count 0))
  1920.  
  1921.     (setf sust (get-sustain))
  1922.  
  1923.  loop
  1924.  
  1925.     (setf sample-count 
  1926.  
  1927.       (truncate (+ 0.5 (* (- (local-to-global (* (car list) sust)) t0)
  1928.  
  1929.                  *control-srate*))))
  1930.  
  1931.     ; now we have a new sample count to put into result list
  1932.  
  1933.     ; make sure result is non-decreasing
  1934.  
  1935.     (cond ((< sample-count last-count)
  1936.  
  1937.        (setf sample-count last-count)))
  1938.  
  1939.     (setf last-count sample-count)
  1940.  
  1941.     (push sample-count result)
  1942.  
  1943.     (cond ((cdr list)
  1944.  
  1945.        (setf list (cdr list))
  1946.  
  1947.        (push (float (car list)) result)))
  1948.  
  1949.     (setf list (cdr list))
  1950.  
  1951.     (cond (list
  1952.  
  1953.        (go loop)))
  1954.  
  1955.     (return (reverse result))))
  1956.  
  1957.  
  1958.  
  1959.       
  1960.  
  1961.  
  1962.  
  1963. ;; (pwl t1 l1 t2 l2 ... tn)
  1964.  
  1965. ;;   Creates a piece-wise linear envelope from breakpoint data.
  1966.  
  1967. ;;
  1968.  
  1969. (defun pwl (&rest breakpoints) (pwl-list breakpoints))
  1970.  
  1971.  
  1972.  
  1973. (defun pwlr (&rest breakpoints) (pwlr-list breakpoints))
  1974.  
  1975.  
  1976.  
  1977. ;; (breakpoints-relative list)
  1978.  
  1979. ;;  converts list, which has the form (value dur value dur value ...)
  1980.  
  1981. ;;  into the form (value time value time value ...)
  1982.  
  1983. ;;  the list may have an even or odd length
  1984.  
  1985. ;;
  1986.  
  1987. (defun breakpoints-relative (breakpoints)
  1988.  
  1989.   (prog (result (sum 0.0))
  1990.  
  1991.  loop
  1992.  
  1993.      (cond (breakpoints
  1994.  
  1995.         (push (car breakpoints) result)
  1996.  
  1997.         (setf breakpoints (cdr breakpoints))
  1998.  
  1999.         (cond (breakpoints
  2000.  
  2001.            (setf sum (+ sum (car breakpoints)))
  2002.  
  2003.            (push sum result)
  2004.  
  2005.            (setf breakpoints (cdr breakpoints))
  2006.  
  2007.            (go loop)))))
  2008.  
  2009.      (return (reverse result))))
  2010.  
  2011.  
  2012.  
  2013.  
  2014.  
  2015. (defun breakpoints-relative (breakpoints)
  2016.  
  2017.   (prog (result (sum 0.0))
  2018.  
  2019.  loop
  2020.  
  2021.     (setf sum (+ sum (car breakpoints)))
  2022.  
  2023.     (push sum result)
  2024.  
  2025.     (cond ((cdr breakpoints)
  2026.  
  2027.        (setf breakpoints (cdr breakpoints))
  2028.  
  2029.        (push (car breakpoints) result)))
  2030.  
  2031.     (setf breakpoints (cdr breakpoints))
  2032.  
  2033.     (cond (breakpoints
  2034.  
  2035.        (go loop)))
  2036.  
  2037.     (return (reverse result))))
  2038.  
  2039.  
  2040.  
  2041.  
  2042.  
  2043. (defun pwlr-list (breakpoints)
  2044.  
  2045.   (pwl-list (breakpoints-relative breakpoints)))
  2046.  
  2047.  
  2048.  
  2049. (defun pwl-list (breakpoints)
  2050.  
  2051.   (let ((t0 (local-to-global 0)))
  2052.  
  2053.     (snd-pwl t0 *control-srate* (breakpoints-convert breakpoints t0))))
  2054.  
  2055.  
  2056.  
  2057. ;; (pwlv l1 t1 l2 t2 ... ln)
  2058.  
  2059. ;; Creates a piece-wise linear envelope from breakpoint data;
  2060.  
  2061. ;; the function initial and final values are explicit
  2062.  
  2063. ;;
  2064.  
  2065. (defun pwlv (&rest breakpoints)
  2066.  
  2067.   ;use pwl, modify breakpoints with initial and final changes
  2068.  
  2069.   ;need to put initial time of 0, and final time of 0
  2070.  
  2071.   (pwlv-list breakpoints))
  2072.  
  2073.  
  2074.  
  2075. (defun pwlv-list (breakpoints)
  2076.  
  2077.     (pwl-list (cons 0.0 (append breakpoints '(0.0)))))
  2078.  
  2079.  
  2080.  
  2081. (defun pwlvr (&rest breakpoints) (pwlvr-list breakpoints))
  2082.  
  2083.  
  2084.  
  2085. (defun pwlvr-list (breakpoints)
  2086.  
  2087.   (pwlr-list (cons 0.0 (append breakpoints '(0.0)))))
  2088.  
  2089.  
  2090.  
  2091. (defun pwe (&rest breakpoints)
  2092.  
  2093.   (pwe-list breakpoints))
  2094.  
  2095.  
  2096.  
  2097. (defun pwe-list (breakpoints)
  2098.  
  2099.   (pwev-list (cons 1.0 (append breakpoints '(1.0)))))
  2100.  
  2101.  
  2102.  
  2103. (defun pwer (&rest breakpoints) (pwer-list breakpoints))
  2104.  
  2105.  
  2106.  
  2107. (defun pwer-list (breakpoints)
  2108.  
  2109.   (pwe-list (breakpoints-relative breakpoints)))
  2110.  
  2111.  
  2112.  
  2113. (defun pwev (&rest breakpoints)
  2114.  
  2115.   (pwev-list breakpoints))
  2116.  
  2117.  
  2118.  
  2119. (defun pwev-list (breakpoints)
  2120.  
  2121.   (let ((lis (breakpoints-log breakpoints)))
  2122.  
  2123.     (s-exp (pwl-list lis))))
  2124.  
  2125.  
  2126.  
  2127. (defun pwevr (&rest breakpoints) (pwevr-list breakpoints))
  2128.  
  2129.  
  2130.  
  2131. (defun pwevr-list (breakpoints)
  2132.  
  2133.   (pwev-list (cdr (breakpoints-relative (cons 0.0 breakpoints)))))
  2134.  
  2135.  
  2136.  
  2137.  
  2138.  
  2139. (defun breakpoints-log (breakpoints)
  2140.  
  2141.   (prog ((result '(0.0)) val tim)
  2142.  
  2143. loop
  2144.  
  2145.     (cond (breakpoints
  2146.  
  2147.        (setf val (float (car breakpoints)))
  2148.  
  2149.        (setf breakpoints (cdr breakpoints))
  2150.  
  2151.        (cond (breakpoints
  2152.  
  2153.           (setf tim (car breakpoints))
  2154.  
  2155.           (setf breakpoints (cdr breakpoints))))
  2156.  
  2157.        (setf result (cons tim (cons (log val) result)))
  2158.  
  2159.        (cond ((null breakpoints)
  2160.  
  2161.           (return (reverse result))))
  2162.  
  2163.        (go loop))
  2164.  
  2165.       (t
  2166.  
  2167.        (error "Expected odd number of elements in breakpoint list")))))
  2168.  
  2169.  
  2170.  
  2171.  
  2172.  
  2173. ;; SOUND-WARP -- apply warp function to a sound
  2174.  
  2175. ;; 
  2176.  
  2177. (defun sound-warp (warp-fn signal &optional wrate)
  2178.  
  2179.   (cond (wrate
  2180.  
  2181.      (snd-resamplev signal *sound-srate*
  2182.  
  2183.             (snd-inverse warp-fn (local-to-global 0) wrate)))
  2184.  
  2185.     (t
  2186.  
  2187.      (snd-compose signal 
  2188.  
  2189.               (snd-inverse warp-fn (local-to-global 0) *sound-srate*)))))
  2190.  
  2191.  
  2192.  
  2193. (defun snd-extent (sound maxsamples) 
  2194.  
  2195.     (list (snd-t0 sound)
  2196.  
  2197.       (+ (snd-t0 sound) (/ (snd-length sound maxsamples)
  2198.  
  2199.                    (snd-srate sound)))))
  2200.  
  2201.  
  2202.  
  2203. (setfn snd-flatten snd-length)
  2204.  
  2205.  
  2206.  
  2207. ;; (maketable sound)
  2208.  
  2209. ;;   Creates a table for osc, lfo, etc. by assuming that the samples
  2210.  
  2211. ;;   in sound represent one period.  The sound must start at time 0.
  2212.  
  2213.  
  2214.  
  2215. (defun maketable (sound)
  2216.  
  2217.   (list sound
  2218.  
  2219.     (hz-to-step 
  2220.  
  2221.      (/ 1.0
  2222.  
  2223.         (cadr (snd-extent sound 1000000))))
  2224.  
  2225.     T))
  2226.  
  2227.  
  2228.  
  2229.  
  2230.  
  2231. ;(defmacro endTime (sound)
  2232.  
  2233. ;   `(get-logical-stop ,sound))
  2234.  
  2235.  
  2236.  
  2237.  
  2238.  
  2239. ;(defmacro beginTime (sound)
  2240.  
  2241. ;   `(car (snd-extent ,sound)))
  2242.  
  2243.  
  2244.  
  2245.  
  2246.  
  2247. ; simple stereo pan: as where goes from 0 to 1, sound
  2248.  
  2249. ; is linearly panned from left to right
  2250.  
  2251. ;
  2252.  
  2253. (defun pan (sound where)
  2254.  
  2255.   (vector (mult sound (sum 1 (mult -1 where)))
  2256.  
  2257.       (mult sound where)))
  2258.  
  2259.  
  2260.  
  2261.  
  2262.  
  2263. (defun prod (&rest snds)
  2264.  
  2265.   (cond ((null snds)
  2266.  
  2267.      (snd-zero (local-to-global 0) *sound-srate*))
  2268.  
  2269.     ((null (cdr snds))
  2270.  
  2271.      (car snds))
  2272.  
  2273.     ((null (cddr snds))
  2274.  
  2275.      (nyq:prod2 (car snds) (cadr snds)))
  2276.  
  2277.     (t
  2278.  
  2279.      (nyq:prod2 (car snds) (apply #'prod (cdr snds))))))
  2280.  
  2281.  
  2282.  
  2283. (setfn mult prod)
  2284.  
  2285.  
  2286.  
  2287.  
  2288.  
  2289. ;; (NYQ:PROD-OF-ARRAYS S1 S2) - form pairwise products
  2290.  
  2291. ;
  2292.  
  2293. (defun nyq:prod-of-arrays (s1 s2)
  2294.  
  2295.   (let* ((n (length s1))
  2296.  
  2297.      (p (make-array n)))
  2298.  
  2299.     (cond ((/= n (length s2))
  2300.  
  2301.        (error "unequal number of channels in prod")))
  2302.  
  2303.     (dotimes (i n)
  2304.  
  2305.       (setf (aref p i) (nyq:prod2 (aref s1 i) (aref s2 i))))
  2306.  
  2307.     p))
  2308.  
  2309.  
  2310.  
  2311.  
  2312.  
  2313. ; nyq:prod2 - multiply two arguments
  2314.  
  2315. ; 
  2316.  
  2317. (defun nyq:prod2 (s1 s2)
  2318.  
  2319.   (setf s1 (nyq:coerce-to s1 s2))
  2320.  
  2321.   (setf s2 (nyq:coerce-to s2 s1))
  2322.  
  2323.   (cond ((arrayp s1)
  2324.  
  2325.      (nyq:prod-of-arrays s1 s2))
  2326.  
  2327.     (t
  2328.  
  2329.      (nyq:prod-2-sounds s1 s2))))
  2330.  
  2331.  
  2332.  
  2333.  
  2334.  
  2335. ; (PROD-2-SOUNDS S1 S2) - multiply two sound arguments
  2336.  
  2337. ; 
  2338.  
  2339. (defun nyq:prod-2-sounds (s1 s2)
  2340.  
  2341.   (cond ((numberp s1)
  2342.  
  2343.      (cond ((numberp s2)
  2344.  
  2345.         (* s1 s2))
  2346.  
  2347.            (t
  2348.  
  2349.         (scale s1 s2))))
  2350.  
  2351.     ((numberp s2)
  2352.  
  2353.      (scale s2 s1))
  2354.  
  2355.     (t
  2356.  
  2357.      (let ((s1sr (snd-srate s1))
  2358.  
  2359.            (s2sr (snd-srate s2)))
  2360.  
  2361. ;    (display "nyq:prod-2-sounds" s1sr s2sr)
  2362.  
  2363.         (cond ((> s1sr s2sr)
  2364.  
  2365.            (snd-prod s1 (snd-up s1sr s2)))
  2366.  
  2367.           ((< s1sr s2sr)
  2368.  
  2369.            (snd-prod (snd-up s2sr s1) s2))
  2370.  
  2371.           (t
  2372.  
  2373.            (snd-prod s1 s2)))))))
  2374.  
  2375.  
  2376.  
  2377.  
  2378.  
  2379. ;; RAMP -- linear ramp from 0 to x
  2380.  
  2381. ;;
  2382.  
  2383. (defun ramp (&optional (x 1))
  2384.  
  2385.   (let* ((duration (get-duration x)))
  2386.  
  2387.     (warp-abs nil 
  2388.  
  2389.     (at *rslt*
  2390.  
  2391.         (sustain-abs 1
  2392.  
  2393.         (pwl duration 1 (+ duration (/ *control-srate*))))))))
  2394.  
  2395.  
  2396.  
  2397.  
  2398.  
  2399. (defun resample (snd rate)
  2400.  
  2401.   (cond ((arrayp snd)
  2402.  
  2403.      (let* ((len (length snd))
  2404.  
  2405.         (result (make-array len)))
  2406.  
  2407.         (dotimes (i len)
  2408.  
  2409.         (setf (aref result i)
  2410.  
  2411.               (snd-resample (aref snd i) rate)))
  2412.  
  2413.         result))
  2414.  
  2415.     (t
  2416.  
  2417.      (snd-resample snd rate))))
  2418.  
  2419.  
  2420.  
  2421.  
  2422.  
  2423. (defun scale (amt snd)
  2424.  
  2425.   (cond ((arrayp snd)
  2426.  
  2427.      (let* ((len (length snd))
  2428.  
  2429.         (result (make-array len)))
  2430.  
  2431.         (dotimes (i len)
  2432.  
  2433.         (setf (aref result i) (snd-scale amt (aref snd i))))
  2434.  
  2435.         result))
  2436.  
  2437.     (t
  2438.  
  2439.      (snd-scale amt snd))))
  2440.  
  2441.  
  2442.  
  2443.  
  2444.  
  2445. (setfn s-print-tree snd-print-tree)
  2446.  
  2447.  
  2448.  
  2449. ;; (PEAK sound-expression number-of-samples) - find peak amplitude
  2450.  
  2451. ;
  2452.  
  2453. ; NOTE: this used to be called s-max
  2454.  
  2455. ;
  2456.  
  2457. (defmacro peak (expression maxlen)
  2458.  
  2459.    `(snd-max ',expression ,maxlen))
  2460.  
  2461.  
  2462.  
  2463. ;; (S-MAX S1 S2) - return maximum of S1, S2
  2464.  
  2465. ;
  2466.  
  2467. (defun s-max (s1 s2)
  2468.  
  2469.   (setf s1 (nyq:coerce-to s1 s2))
  2470.  
  2471.   (setf s2 (nyq:coerce-to s2 s1))
  2472.  
  2473.   (cond ((arrayp s1)
  2474.  
  2475.      (nyq:max-of-arrays s1 s2))
  2476.  
  2477.     (t
  2478.  
  2479.      (nyq:max-2-sounds s1 s2))))
  2480.  
  2481.  
  2482.  
  2483. (defun nyq:max-of-arrays (s1 s2)
  2484.  
  2485.   (let* ((n (length s1))
  2486.  
  2487.      (p (make-array n)))
  2488.  
  2489.     (cond ((/= n (length s2))
  2490.  
  2491.        (error "unequal number of channels in max")))
  2492.  
  2493.     (dotimes (i n)
  2494.  
  2495.       (setf (aref p i) (s-max (aref s1 i) (aref s2 i))))
  2496.  
  2497.     p))
  2498.  
  2499.  
  2500.  
  2501. (defun nyq:max-2-sounds (s1 s2)
  2502.  
  2503.   (cond ((numberp s1)
  2504.  
  2505.          (cond ((numberp s2)
  2506.  
  2507.                 (max s1 s2))
  2508.  
  2509.                (t
  2510.  
  2511.                 (snd-maxv s2
  2512.  
  2513.                           (snd-const s1 (local-to-global 0.0)
  2514.  
  2515.                                      (snd-srate s2) (get-duration 1.0))))))
  2516.  
  2517.         ((numberp s2)
  2518.  
  2519.          (snd-maxv s1 (snd-const s2 (local-to-global 0.0)
  2520.  
  2521.                    (snd-srate s1) (get-duration 1.0))))
  2522.  
  2523.         (t
  2524.  
  2525.          (let ((s1sr (snd-srate s1))
  2526.  
  2527.                (s2sr (snd-srate s2)))
  2528.  
  2529.             (cond ((> s1sr s2sr)
  2530.  
  2531.                    (snd-maxv s1 (snd-up s1sr s2)))
  2532.  
  2533.                   ((< s1sr s2sr)
  2534.  
  2535.                    (snd-maxv (snd-up s2sr s1) s2))
  2536.  
  2537.                   (t
  2538.  
  2539.                    (snd-maxv s1 s2)))))))
  2540.  
  2541.  
  2542.  
  2543. (defun s-min (s1 s2)
  2544.  
  2545.   (setf s1 (nyq:coerce-to s1 s2))
  2546.  
  2547.   (setf s2 (nyq:coerce-to s2 s1))
  2548.  
  2549.   (cond ((arrayp s1)
  2550.  
  2551.          (nyq:min-of-arrays s1 s2))
  2552.  
  2553.         (t
  2554.  
  2555.          (nyq:min-2-sounds s1 s2))))
  2556.  
  2557.  
  2558.  
  2559. (defun nyq:min-of-arrays (s1 s2)
  2560.  
  2561.   (let* ((n (length s1))
  2562.  
  2563.      (p (make-array n)))
  2564.  
  2565.     (cond ((/= n (length s2))
  2566.  
  2567.        (error "unequal number of channels in max")))
  2568.  
  2569.     (dotimes (i n)
  2570.  
  2571.       (setf (aref p i) (s-min (aref s1 i) (aref s2 i))))
  2572.  
  2573.     p))
  2574.  
  2575.  
  2576.  
  2577. (defun nyq:min-2-sounds (s1 s2)
  2578.  
  2579.   (cond ((numberp s1)
  2580.  
  2581.      (cond ((numberp s2)
  2582.  
  2583.         (min s1 s2))
  2584.  
  2585.            (t
  2586.  
  2587.         (snd-minv
  2588.  
  2589.          (snd-const s1 (local-to-global 0.0)
  2590.  
  2591.                 (snd-srate s2) (get-duration 1.0))))))
  2592.  
  2593.     ((numberp s2)
  2594.  
  2595.      (snd-minv (snd-const s2 (local-to-global 0.0)
  2596.  
  2597.                 (snd-srate s1) (get-duration 1.0))))
  2598.  
  2599.     (t
  2600.  
  2601.      (let ((s1sr (snd-srate s1))
  2602.  
  2603.            (s2sr (snd-srate s2)))
  2604.  
  2605.         (cond ((> s1sr s2sr)
  2606.  
  2607.            (snd-minv s1 (snd-up s1sr s2)))
  2608.  
  2609.           ((< s1sr s2sr)
  2610.  
  2611.            (snd-minv (snd-up s2sr s1) s2))
  2612.  
  2613.           (t
  2614.  
  2615.            (snd-minv s1 s2)))))))
  2616.  
  2617.  
  2618.  
  2619. (defun snd-minv (s1 s2)
  2620.  
  2621.   (scale -1.0 (snd-maxv (scale -1.0 s1) (scale -1.0 s2))))
  2622.  
  2623.  
  2624.  
  2625. ; sequence macros SEQ and SEQREP are now in seq.lsp:
  2626.  
  2627. ; 
  2628.  
  2629. (load "seq" :verbose NIL)
  2630.  
  2631.  
  2632.  
  2633. ; set-logical-stop - modify the sound and return it, time is shifted and
  2634.  
  2635. ;             stretched
  2636.  
  2637. (defun set-logical-stop (snd tim)
  2638.  
  2639.   (let ((d (local-to-global tim)))
  2640.  
  2641.     (multichan-expand #'set-logical-stop-abs snd d)))
  2642.  
  2643.  
  2644.  
  2645.  
  2646.  
  2647. ; set-logical-stop-abs - modify the sound and return it
  2648.  
  2649. ; 
  2650.  
  2651. (defun set-logical-stop-abs (snd tim) (snd-set-logical-stop snd tim) snd)
  2652.  
  2653.  
  2654.  
  2655.  
  2656.  
  2657. (defmacro simrep (pair sound)
  2658.  
  2659.   `(let (_snds)
  2660.  
  2661.      (dotimes ,pair (push ,sound _snds))
  2662.  
  2663.      (sim-list _snds)))
  2664.  
  2665.  
  2666.  
  2667. (defun sim (&rest snds)
  2668.  
  2669.   (sim-list snds))
  2670.  
  2671.  
  2672.  
  2673. (setfn sum sim)
  2674.  
  2675.  
  2676.  
  2677. (defun sim-list (snds)
  2678.  
  2679.   (cond ((null snds)
  2680.  
  2681.      (snd-zero (local-to-global 0) *sound-srate*))
  2682.  
  2683.     ((null (cdr snds))
  2684.  
  2685.      (car snds))
  2686.  
  2687.     ((null (cddr snds))
  2688.  
  2689.      (nyq:add2 (car snds) (cadr snds)))
  2690.  
  2691.     (t
  2692.  
  2693.      (nyq:add2 (car snds) (sim-list (cdr snds))))))
  2694.  
  2695.  
  2696.  
  2697.  
  2698.  
  2699. ;(defun rest (&optional (dur 1.0))
  2700.  
  2701. ;  (cue (set-Logical-stop (* dur *stretch*) (s-create))))
  2702.  
  2703. (defun s-rest (&optional (dur 1.0))
  2704.  
  2705.   (let ((d (get-duration dur)))
  2706.  
  2707.     (snd-const 0.0 *rslt* *SOUND-SRATE* d)))
  2708.  
  2709.  
  2710.  
  2711.  
  2712.  
  2713. (defun tempo (warpfn)
  2714.  
  2715.   (slope (snd-inverse warpfn (local-to-global 0) *control-srate*)))
  2716.  
  2717.  
  2718.  
  2719.  
  2720.  
  2721.  
  2722.  
  2723. ;; (SUM-OF-ARRAYS S1 S2) - add multichannel sounds
  2724.  
  2725. ; 
  2726.  
  2727. ; result has as many channels the largest of s1, s2
  2728.  
  2729. ; corresponding channels are added, extras are copied
  2730.  
  2731. ; 
  2732.  
  2733. (defun sum-of-arrays (s1 s2)
  2734.  
  2735.   (let* ((n1 (length s1))
  2736.  
  2737.      (n2 (length s2))
  2738.  
  2739.      (n (min n1 n2))
  2740.  
  2741.      (m (max n1 n2))
  2742.  
  2743.      (result (make-array m))
  2744.  
  2745.      (big-s (if (> n1 n2) s1 s2)))
  2746.  
  2747.     
  2748.  
  2749.     (dotimes (i n)
  2750.  
  2751.       (setf (aref result i) (nyq:add-2-sounds (aref s1 i) (aref s2 i))))
  2752.  
  2753.     (dotimes (i (- m n))
  2754.  
  2755.       (setf (aref result (+ n i)) (aref big-s (+ n i))))
  2756.  
  2757.     result))
  2758.  
  2759.  
  2760.  
  2761.  
  2762.  
  2763. ;; (WARP fn behavior) - warp behavior according to fn
  2764.  
  2765. ;;
  2766.  
  2767. ;; fn is a map from behavior time to local time, and *WARP* expresses
  2768.  
  2769. ;; a map from local to global time.
  2770.  
  2771. ;; To produce a new *WARP* for the environment, we want to compose the
  2772.  
  2773. ;; effect of the current *WARP* with fn.  Note that fn is also a behavior.
  2774.  
  2775. ;; It is evaluated in the current environment first, then it is used to
  2776.  
  2777. ;; modify the environment seen by behavior.
  2778.  
  2779. ;; *WARP* is a triple: (d s f) denoting the function f(st+d).
  2780.  
  2781. ;; Letting g represent the new warp function fn, we want f(st+d) o g, or
  2782.  
  2783. ;; f(s*g(t) + d) in the form (d' s' f').
  2784.  
  2785. ;; Let's do this one step at a time:
  2786.  
  2787. ;; f(s*g(t) + d) = f(scale(s, g) + d)
  2788.  
  2789. ;;               = (shift f -d)(scale(s, g))
  2790.  
  2791. ;;               = (snd-compose (shift-time f (- d)) (scale s g))
  2792.  
  2793. ;;
  2794.  
  2795. ;; If f in NIL, it denotes the identity mapping f(t)=t, so we can
  2796.  
  2797. ;; simplify:
  2798.  
  2799. ;; f(scale(s, g) + d) = scale(s, g) + d
  2800.  
  2801. ;;                    = (snd-offset (scale s g) d)
  2802.  
  2803.  
  2804.  
  2805. (defmacro warp (x s)
  2806.  
  2807.  `(progv '(*WARP*) (list 
  2808.  
  2809.             (list 0.0 1.0
  2810.  
  2811.               (if (warp-function *WARP*)
  2812.  
  2813.                   (snd-compose (shift-time (warp-function *WARP*) 
  2814.  
  2815.                                (- (warp-time *WARP*)))
  2816.  
  2817.                        (scale (warp-stretch *WARP*) 
  2818.  
  2819.                           (must-be-sound ,x)))
  2820.  
  2821.                   (snd-offset (scale (warp-stretch *WARP*) 
  2822.  
  2823.                          (must-be-sound ,x))
  2824.  
  2825.                       (warp-time *WARP*)))))
  2826.  
  2827.      ,s))
  2828.  
  2829.  
  2830.  
  2831.  
  2832.  
  2833. (defmacro warp-abs (x s)
  2834.  
  2835.  `(progv '(*WARP*) (list (list 0.0 1.0 ,x))
  2836.  
  2837.      ,s))
  2838.  
  2839.  
  2840.  
  2841.  
  2842.  
  2843. ;; MULTICHAN-EXPAND -- construct and return array according to args
  2844.  
  2845. ;;
  2846.  
  2847. ;; arrays are used in Nyquist to represent multiple channels
  2848.  
  2849. ;; if any argument is an array, make sure all array arguments
  2850.  
  2851. ;; have the same length.  Then, construct a multichannel result
  2852.  
  2853. ;; by calling fn once for each channel.  The arguments passed to
  2854.  
  2855. ;; fn for the i'th channel are either the i'th element of an array
  2856.  
  2857. ;; argument, or just a copy of a non-array argument.
  2858.  
  2859. ;;
  2860.  
  2861. (defun multichan-expand (fn &rest args)
  2862.  
  2863.   (let (len newlen result) ; len is a flag as well as a count
  2864.  
  2865.     (dolist (a args)
  2866.  
  2867.         (cond ((arrayp a)
  2868.  
  2869.            (setf newlen (length a))
  2870.  
  2871.            (cond ((and len (/= len newlen))
  2872.  
  2873.               (error (format nil "In ~A, two arguments are vectors of differing length." fn))))
  2874.  
  2875.            (setf len newlen))))
  2876.  
  2877.     (cond (len
  2878.  
  2879.        (setf result (make-array len))
  2880.  
  2881.        ; for each channel, call fn with args
  2882.  
  2883.        (dotimes (i len)
  2884.  
  2885.            (setf (aref result i)
  2886.  
  2887.              (apply fn
  2888.  
  2889.             (mapcar
  2890.  
  2891.                 #'(lambda (a)
  2892.  
  2893.                 ; take i'th entry or replicate:
  2894.  
  2895.                 (cond ((arrayp a) (aref a i))
  2896.  
  2897.                       (t a)))
  2898.  
  2899.                 args))))
  2900.  
  2901.        result)
  2902.  
  2903.       (t
  2904.  
  2905.        (apply fn args)))))
  2906.  
  2907.  
  2908.  
  2909.  
  2910.  
  2911. ;; SELECT-IMPLEMENTATION-? -- apply an implementation according to args
  2912.  
  2913. ;;
  2914.  
  2915. ;; There is a different Nyquist primitive for each combination of 
  2916.  
  2917. ;; constant (NUMBERP) and time-variable (SOUNDP) arguments.  E.g.
  2918.  
  2919. ;; a filter with fixed parameters differs from one with varying
  2920.  
  2921. ;; parameters.  In most cases, the user just calls one function,
  2922.  
  2923. ;; and the arguments are decoded here:
  2924.  
  2925.  
  2926.  
  2927.  
  2928.  
  2929. ;; SELECT-IMPLEMENTATION-1-1 -- 1 sound arg, 1 selector
  2930.  
  2931. ;;
  2932.  
  2933. (defun select-implementation-1-1 (fns snd sel1 &rest others)
  2934.  
  2935.   (if (numberp sel1)
  2936.  
  2937.     (apply (aref fns 0) (cons snd (cons sel1 others)))
  2938.  
  2939.     (apply (aref fns 1) (cons snd (cons sel1 others)))))
  2940.  
  2941.  
  2942.  
  2943.  
  2944.  
  2945. ;; SELECT-IMPLEMENTATION-1-2 -- 1 sound arg, 2 selectors
  2946.  
  2947. ;;
  2948.  
  2949. ;; choose implemenation according to args 2 and 3
  2950.  
  2951. ;;
  2952.  
  2953. (defun select-implementation-1-2 (fns snd sel1 sel2 &rest others)
  2954.  
  2955.   (if (numberp sel2)
  2956.  
  2957.     (if (numberp sel1)
  2958.  
  2959.       (apply (aref fns 0) (cons snd (cons sel1 (cons sel2 others))))
  2960.  
  2961.       (apply (aref fns 1) (cons snd (cons sel1 (cons sel2 others)))))
  2962.  
  2963.     (if (numberp sel1)
  2964.  
  2965.       (apply (aref fns 2) (cons snd (cons sel1 (cons sel2 others))))
  2966.  
  2967.       (apply (aref fns 3) (cons snd (cons sel1 (cons sel2 others)))))))
  2968.  
  2969.  
  2970.  
  2971. ;; some waveforms
  2972.  
  2973.  
  2974.  
  2975. (setf *saw-table* (pwlvr -1 1 1))        ; eh, creepy way to get 2205 samples.
  2976.  
  2977. (setf *saw-table* (list *saw-table* (hz-to-step 1) T))
  2978.  
  2979.  
  2980.  
  2981. (setf *tri-table* (pwlvr -1 0.5 1 0.5 -1))
  2982.  
  2983. (setf *tri-table* (list *tri-table* (hz-to-step 1) T))
  2984.  
  2985.  
  2986.  
  2987. (setf *id-shape*  (pwlvr -1 2 1 .01 1))                ; identity
  2988.  
  2989. (setf *step-shape* (seq (const -1) (const 1 1.01)))  ; hard step at zero
  2990.  
  2991.  
  2992.  
  2993. (defun exp-dec (hold halfdec length)
  2994.  
  2995.   (let* ((target (expt 0.5 (/ length halfdec)))
  2996.  
  2997.      (expenv (pwev 1 hold 1 length target)))
  2998.  
  2999.     expenv)
  3000.  
  3001. )
  3002.  
  3003.  
  3004.  
  3005. ;;; operations on sounds
  3006.  
  3007.  
  3008.  
  3009. (defun diff (x y) (sum x (prod -1 y)))
  3010.  
  3011.  
  3012.  
  3013. ; compare-shape is a shape table -- origin 1.
  3014.  
  3015. (defun compare (x y &optional (compare-shape *step-shape*))
  3016.  
  3017.   (let ((xydiff (diff x y)))
  3018.  
  3019.     (shape xydiff compare-shape 1)))
  3020.  
  3021.  
  3022.  
  3023. ;;; oscs
  3024.  
  3025.  
  3026.  
  3027. (defun osc-saw (hz) (hzosc hz *saw-table*))
  3028.  
  3029. (defun osc-tri (hz) (hzosc hz *tri-table*))
  3030.  
  3031.  
  3032.  
  3033. ; bias is [-1, 1] pulse width.  sound or scalar.
  3034.  
  3035. ; hz is a sound or scalar
  3036.  
  3037. (defun osc-pulse (hz bias &optional (compare-shape *step-shape*))
  3038.  
  3039.   (compare bias (osc-tri hz) compare-shape))
  3040.  
  3041.  
  3042.  
  3043.  
  3044.  
  3045.